home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / state.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  80 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Compiler state, including flags controlling debug data retention.
  5.  
  6.  
  7. ; Package and location uids and the location name table should be here
  8. ; as well...
  9.  
  10. ; Will the use of a fluid variable significantly degrade performance?
  11.  
  12. (define (new-template-uid)
  13.   (let ((uid *template-uid*))
  14.     (set! *template-uid* (+ *template-uid* 1))
  15.     uid))
  16.  
  17. (define *template-uid* 5000)  ; 1548 in initial system as of 1/22/94
  18.  
  19. (define (template-uid) *template-uid*)
  20. (define (set-template-uid! uid) (set! *template-uid* uid))
  21.  
  22.  
  23.  
  24. ; These variables really ought to be dynamically scoped, not global.
  25. ; Fix this some day.
  26.  
  27. (define debug-flag-names '(names maps files source tabulate table))
  28.  
  29. (define type/debug-flags
  30.   (make-record-type 'debug-flags debug-flag-names))
  31.  
  32. (define make-debug-flags
  33.   (record-constructor type/debug-flags debug-flag-names))
  34.  
  35. (define $debug-flags
  36.   (make-fluid (make-debug-flags #t    ;proc names
  37.                 #f    ;env maps
  38.                 #f    ;no file names
  39.                 #f    ;no cont source
  40.                 #f    ;no tabulate
  41.                 (make-table))))
  42.  
  43. (define (debug-flag-accessor name)
  44.   (let ((access (record-accessor type/debug-flags name)))
  45.     (lambda () (access (fluid $debug-flags)))))
  46.  
  47. (define (debug-flag-modifier name)
  48.   (let ((modify (record-modifier type/debug-flags name)))
  49.     (lambda (new) (modify (fluid $debug-flags) new))))
  50.  
  51. (define keep-source-code?      (debug-flag-accessor 'source))
  52. (define keep-environment-maps? (debug-flag-accessor 'maps))
  53. (define keep-procedure-names?  (debug-flag-accessor 'names))
  54. (define keep-file-names?       (debug-flag-accessor 'files))
  55. (define tabulate-debug-data?   (debug-flag-accessor 'tabulate))
  56. (define debug-data-table       (debug-flag-accessor 'table))
  57.  
  58.  
  59. ; Kludge for static linker.
  60.  
  61. (define (with-fresh-compiler-state template-uid-origin thunk)
  62.   (let-fluid $debug-flags (make-debug-flags #t ;proc names
  63.                         #f ;env maps
  64.                         #f ;no file names
  65.                         #f ;no cont source
  66.                         #t ;tabulate       ***
  67.                         (make-table))
  68.     (lambda ()
  69.       (saving-and-restoring (lambda () *template-uid*)
  70.                 (lambda (s) (set! *template-uid* s))
  71.                 template-uid-origin
  72.                 thunk))))
  73.  
  74. (define (saving-and-restoring fetch store! other thunk)
  75.   (let ((swap (lambda ()
  76.         (let ((temp (fetch)))
  77.           (store! other)
  78.           (set! other temp)))))
  79.     (dynamic-wind swap thunk swap)))
  80.